home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / root-gmgmt.l < prev    next >
Text File  |  1989-07-12  |  5KB  |  128 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                   P.O. BOX 2909                                  |
  8. ;;;                                AUSTIN, TEXAS 78769                               |
  9. ;;;                                                                                  |
  10. ;;;                Copyright (C) 1989 Texas Instruments Incorporated.                |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package 'cluei :use '(lisp xlib clos))
  22.  
  23.  
  24. ;;;----------------------------------------------------------------------------+
  25. ;;;                                                                            |
  26. ;;;                  Geometry management methods for ROOT contacts             |
  27. ;;;                                                                            |
  28. ;;;----------------------------------------------------------------------------+
  29.  
  30. (defmethod manage-geometry ((parent root) (shell wm-shell) x y width height border-width &key) 
  31.   (declare (type contact shell)
  32.        (type (or null int16) x y)
  33.        (type (or null card16) width height border-width)
  34.        (values success-p x y width height border-width))
  35.  
  36.   (with-slots ((contact-x x)
  37.            (contact-y y)
  38.            (contact-width width)
  39.            (contact-height height)
  40.            (contact-border-width border-width)) (the contact shell)
  41.     
  42.     (if (realized-p shell)
  43.  
  44.     ;; Negotiate top-level geometry with window mgr
  45.     (with-event-mode (shell '(:configure-notify (throw-action :configure-notify)))      
  46.       ;; Reconfigure top-level window, if necessary
  47.       (let (changed-p)
  48.         (with-state (shell)
  49.           (when (and x (/= x contact-x)
  50.              (setf (drawable-x shell) x))
  51.         (setf changed-p t))
  52.           (when (and y (/= y contact-y)
  53.              (setf (drawable-y shell) y))
  54.         (setf changed-p t))
  55.           (when (and width (/= width contact-width)
  56.              (setf (drawable-width shell) width))
  57.         (setf changed-p t))
  58.           (when (and height (/= height contact-height)
  59.              (setf (drawable-height shell) height))
  60.         (setf changed-p t))
  61.           (when (and border-width (/= border-width contact-border-width)
  62.              (setf (drawable-border-width shell) border-width))
  63.         (setf changed-p t)))
  64.         
  65.         ;; Return approved geometry
  66.         (values
  67.           (or
  68.         ;; Null changed approved immediately
  69.         (not changed-p)
  70.         
  71.         ;; Actual change approved if it is not modified by window mgr.
  72.         (progn
  73.           ;; Wait for :configure-notify to report actual new window geometry.
  74.           ;; Top-level shell's handle-event will update geometry slots in
  75.           ;; response to :configure-notify.          
  76.           (catch :configure-notify
  77.             (loop (process-next-event (contact-display parent))))
  78.           
  79.           ;; Assert: shell slots now contain actual (wm-approved) geometry
  80.           ;; Return approval of original geometry request
  81.           (and
  82.             (not (and x (/= x contact-x)))
  83.             (not (and y (/= y contact-y)))
  84.             (not (and width (/= width contact-width)))
  85.             (not (and height (/= height contact-height)))
  86.             (not (and border-width (/= border-width contact-border-width))))))
  87.           
  88.           contact-x contact-y contact-width contact-height contact-border-width)))
  89.  
  90.     ;; Else approve change to unrealized shell immediately
  91.     (values t
  92.         (or x contact-x) (or y contact-y)
  93.         (or width contact-width) (or height contact-height)
  94.         (or border-width contact-border-width)))))
  95.  
  96.  
  97. (defmethod manage-priority ((parent root) (shell wm-shell) priority sibling &key)  
  98.   (declare (type (member :above :below :top-if :bottom-if :opposite) priority)
  99.        (type (or null contact) sibling)
  100.        (values success-p priority sibling))
  101.       
  102.   (with-event-mode (shell '(:configure-notify return-above-sibling))
  103.     
  104.     ;; Reconfigure top-level window
  105.     (setf (window-priority shell sibling) priority)
  106.     
  107.     ;; Wait for :configure-notify to report actual new window priority.
  108.     (let ((above-sibling
  109.         (catch :configure-notify
  110.           (loop (process-next-event (contact-display parent))))))
  111.       
  112.       ;; Return approval for original priority request
  113.       (values
  114.     (and (eq sibling above-sibling) (eq priority :above))
  115.     :above))))
  116.  
  117.  
  118. (defun return-above-sibling (shell)
  119.   (declare (ignore shell))
  120.   (with-event (above-sibling)
  121.     (throw :configure-notify above-sibling)))
  122.  
  123.  
  124. (defmethod change-layout ((parent root) &optional newly-managed)
  125.   (declare (ignore newly-managed)) 
  126.   ;; Adding/deleting root children has no effect on sibling layout
  127.   )
  128.